home *** CD-ROM | disk | FTP | other *** search
/ MacWorld UK 2000 March / MW_UK_2000_03.iso / Shareware World / Utilities / Text Processing / Alpha / Tcl / Modes / shellMode.tcl < prev    next >
Encoding:
Text File  |  1999-11-29  |  21.7 KB  |  811 lines  |  [TEXT/ALFA]
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  # 
  4.  #  FILE: "shellMode.tcl"
  5.  #                                last update: 29/11/1999 {12:58:18 pm} 
  6.  #  Author: Vince Darley, Pete Keleher
  7.  #  E-mail: <vince@santafe.edu>
  8.  #    mail: Division of Engineering and Applied Sciences, Harvard University
  9.  #          Oxford Street, Cambridge MA 02138, USA
  10.  #     www: <http://www.santafe.edu/~vince/>
  11.  #  
  12.  # Some Copyright (c) 1997-1998  Vince Darley, all rights reserved
  13.  # Some copyright Pete Keleher.
  14.  # 
  15.  #  Description: 
  16.  # 
  17.  # General purpose shell routines for Alpha.  Two and a half shells
  18.  # are provided by default: the Alpha Tcl shell, the MPW toolserver
  19.  # shell and half of the comet shell (whatever that is).
  20.  # 
  21.  # A separate package 'remotetclshell' allows Alpha to act as a console
  22.  # for a separately running Wish.
  23.  # ###################################################################
  24.  ##
  25.  
  26. alpha::mode Shel 1.8.0 dummyShel [list {"*tcl sh*"}] tclMenu {
  27.     addMode MPW {} [list "*Toolserver shell*"] {}
  28.     # we use our own version since Alpha doesn't quite change mode
  29.     # to Shel correctly (not sure what it does wrong).
  30.     catch {rename shell {}}
  31.     # we do this ourselves.  this way we don't need a special hack
  32.     # in 'openHook'
  33.     catch {rename toolserverShell {}}
  34. }
  35.  
  36. set Shel::startPrompt "«"
  37. set Shel::endPrompt "»"
  38.  
  39. newPref v wordBreak {(\$)?[a-zA-Z0-9_.]+} Shel
  40. newPref f wordWrap {0} Shel
  41. newPref f perlCallUnixLike {0} Shel
  42. newPref v wordBreakPreface "\[^a-zA-Z0-9_\\$${Shel::endPrompt}\]" Shel
  43. newPref f autoMark 0 Shel
  44. newPref f tcl_interactive 1 Shel
  45.  
  46. set invisibleModeVars(tcl_interactive) 1
  47. set Shel::endPara "^${Shel::startPrompt}.*$"
  48. set Shel::startPara "^${Shel::startPrompt}.*$"
  49. regModeKeywords -m ${Shel::startPrompt} Shel {}
  50.  
  51. ensureset Shel::histnum 0
  52.  
  53. Bind '\r' Shel::carriageReturn "Shel"
  54. Bind '\r' Shel::carriageReturn "MPW"
  55. Bind '\t' bind::Completion Shel
  56.  
  57. Bind up <z> Shel::prevHist Shel
  58. Bind down <z> Shel::nextHist Shel
  59.  
  60. Bind 'a' <z> Shel::Bol Shel
  61. Bind up Shel::up Shel
  62. Bind down Shel::down Shel
  63.  
  64. Bind 'u' <z> Shel::killLine Shel
  65.  
  66. proc dummyShel {} {}
  67.  
  68. ensureset otherDirs {}
  69.  
  70. proc Shel::OptionTitlebar {} {
  71.     regsub -all "\n *" [history] "\} \{" h
  72.     set h "\{[string trim $h]\}"
  73. }
  74.  
  75. proc Shel::OptionTitlebarSelect {item} {
  76.     insertText [string range $item [expr 2+[string first " " $item]] end]
  77.     Shel::carriageReturn
  78. }
  79.  
  80. proc Shel::DblClick {args} { eval Tcl::DblClick $args }
  81.  
  82. ## 
  83.  # -------------------------------------------------------------------------
  84.  # 
  85.  # "Shel::carriageReturn" --
  86.  # 
  87.  #  Rewritten to avoid need for global _text _return variables
  88.  # -------------------------------------------------------------------------
  89.  ##
  90. proc Shel::carriageReturn {} {
  91.     global mode histnum Shel::Type Shel::endPrompt
  92.     set pos [getPos]
  93.  
  94.     if {![catch {regexp {∞} [getText $pos [nextLineStart $pos]]} res] && $res} {
  95.     gotoMatch; return;
  96.     }
  97.     set ind [string first ${Shel::endPrompt} [getText [lineStart $pos] $pos]]
  98.     if {$ind < 0} {
  99.     insertText "\r"
  100.     return
  101.     }
  102.     endOfLine
  103.     set fileName [win::CurrentTail]
  104.     set type [set Shel::Type($fileName)]
  105.     # sort out where we're going to put the answer
  106.     set t [getText [pos::math [lineStart $pos] + [expr $ind+2]] [getPos]]
  107.  
  108.     if {[pos::compare [getPos] != [maxPos]]} {
  109.     goto [set pos [maxPos]]
  110.     set ind [string first ${Shel::endPrompt} [getText [lineStart $pos] $pos]]
  111.     if {$ind < 0} {
  112.         insertText "\r" [${type}::Prompt]
  113.     } else {
  114.         set ind [pos::math [lineStart $pos] + [expr $ind +2]]
  115.         if {$ind != $pos} {
  116.         deleteText $ind $pos
  117.         }
  118.     }
  119.     insertText -w $fileName $t
  120.     }
  121.     # carry out the action
  122.     insertText -w $fileName "\r"
  123.     set r [${type}::evaluate $t]
  124.     insertText -w $fileName $r 
  125.     if {$r != ""} { 
  126.     insertText -w $fileName "\r"
  127.     }
  128.     insertText -w $fileName [${type}::Prompt]
  129. }
  130.  
  131. proc Shel::start {type {title ""} {startuptext ""}} {
  132.     if {$title != ""} {
  133.     if {[lsearch -exact [winNames] $title] != -1} {
  134.         bringToFront $title
  135.         return
  136.     }
  137.     new -n $title -m Shel -shell 1 -text $startuptext
  138.     }
  139.     global Shel::Type
  140.     set c [win::Current]
  141.     set Shel::Type($c) $type
  142.     insertText -w $c [${type}::Prompt]
  143. }
  144.  
  145. # ◊◊◊◊ Alpha shell routines ◊◊◊◊ #
  146.  
  147. proc tclLog {args} {
  148.     catch {eval insertText -w [list "*tcl shell*"] $args}
  149. }
  150.  
  151. proc shell {} {
  152.     Shel::start "Alpha" "*tcl shell*" "Welcome to Alpha's Tcl shell.\r"
  153. }
  154.  
  155. namespace eval Alpha {}
  156.  
  157. proc Alpha::evaluate {t} {
  158.     global errorInfo Shel::histnum
  159.     global Shel::AlphaAlias
  160.     history add $t
  161.     set msg {}
  162.     set lt [expandAliases $t Tcl]
  163.     switch -regexp -- $lt {
  164.     {^\s*alias\s+.*} {
  165.         message "alias to be added"
  166.         if {[llength $lt] != 3} {
  167.         set msg "Error: wrong number of arguments.\rForm is: alias <abrev> <replacement>"
  168.         } else {
  169.         catch {Shel::alias [lindex $lt 1] [lrange $lt 2 2]} msg
  170.         } 
  171.         
  172.     }
  173.     default {
  174.         if {[set code [catch {uplevel \#0 $lt} msg]] == 1} {
  175.         # strip off end of error due to 'uplevel' command
  176.         set new [split $errorInfo \n]
  177.         set new [join [lrange $new 0 [expr [llength $new] - 4]] \n]
  178.         set errorInfo "$new"
  179.         set msg "Error: $msg"
  180.         }
  181.     }
  182.     }
  183.     set Shel::histnum [history nextid]
  184.     return $msg
  185.     
  186. }
  187.  
  188. proc Alpha::Prompt {} {
  189.     global Shel::startPrompt Shel::endPrompt
  190.     return "${Shel::startPrompt}[file tail [string trimright [pwd] {:}]]${Shel::endPrompt} "
  191. }
  192.  
  193. # ◊◊◊◊ MPW routines ◊◊◊◊ #
  194. namespace eval mpw {}
  195. proc mpw::evaluate {t} {
  196.     catch {dosc -n ToolServer -s $t} r
  197.     return $r
  198. }
  199. proc mpw::Prompt {} { 
  200.     global Shel::startPrompt Shel::endPrompt
  201.     return "${Shel::startPrompt}mpw${Shel::endPrompt} " 
  202. }
  203.     
  204. proc toolserverShell {} {
  205.     Shel::start "mpw" {*Toolserver shell*} \
  206.       "Welcome to Alpha's MPW shell (using ToolServer via AppleEvents).\r"
  207.     if {[catch {app::ensureRunning MPSX}]} {
  208.     killWindow
  209.     }
  210. }
  211.  
  212. # ◊◊◊◊ Comet routines ◊◊◊◊ #
  213. namespace eval comet {}
  214. proc comet::evaluate {t} {
  215.     cometSendAndPrompt $t
  216.     return ""
  217. }
  218. proc comet::Prompt {} {}
  219.  
  220. # ◊◊◊◊ General purpose ◊◊◊◊ #
  221.  
  222. proc expandAliases {cmdLine {shellType Tcl}} {
  223.     global Shel::AlphaAlias
  224.     if {![info exists Shel::AlphaAlias]} {
  225.     return $cmdLine 
  226.     } 
  227.     while {[string length $cmdLine]} {
  228.     if {[regexp -indices -- \
  229.       {([$]\{?|set\s+)?\b([a-zA-Z_][a-zA-Z_0-9]*)\b(([\.]|(::))[a-zA-Z_0-9]*)*} \
  230.       $cmdLine all dc poss]} {
  231.         if {$all != $poss} {
  232.         set end [lindex $all 1]
  233.         append rtnVal [string range $cmdLine 0 $end]
  234.         set cmdLine [string range $cmdLine [incr end] end]
  235.         } else {
  236.         set start [lindex $poss 0]
  237.         set end [lindex $poss 1]
  238.         if {$start != 0} {
  239.             append rtnVal [string range $cmdLine 0 [expr $start - 1]]                
  240.         } 
  241.         set possAlias [string range $cmdLine $start $end]
  242.         if {[info exists Shel::AlphaAlias($possAlias)]} {
  243.             append rtnVal [set Shel::AlphaAlias($possAlias)] 
  244.         } else {
  245.             append rtnVal [string range $cmdLine $start $end]
  246.         } 
  247.         set cmdLine [string range $cmdLine [incr end] end]
  248.         } 
  249.     } else {
  250.         append rtnVal $cmdLine
  251.         break
  252.     }
  253.     }
  254.     return $rtnVal
  255. }
  256.  
  257. proc Shel::alias {abrev replacement} {
  258.     global Shel::Type
  259.     set fileName [win::CurrentTail]
  260.     set type [set Shel::Type($fileName)]
  261.     
  262.     if {![regexp -- $abrev {[a-zA-Z_][a-zA-Z_0-9]*}]} {
  263.     return "The name used for an alias must start with an alphabetic character \
  264.       \nor an underscore, followed by zero or more characters of the same sort \
  265.       \n(with numbers allowed also)."
  266.     }
  267.     
  268.     if {"[info commands $abrev][procs::find $abrev]" != ""} {
  269.     beep
  270.     if {![string match [askyesno -c "'$abrev' is already a Tcl command, do you wish to Cancel?"] no ] } {
  271.         return "No alias was formed"
  272.     }        
  273.     } 
  274.     
  275.     global Shel::${type}Alias
  276.     if {[info exists Shel::${type}Alias($abrev)]} {
  277.     beep
  278.     if {![string match [askyesno -c "'$abrev' is already an alias for this shell, do you wish to Cancel?" ] no ] } {
  279.         return "No alias was formed"
  280.     } 
  281.     } 
  282.     mode::addUserLine [list set Shel::${type}Alias($abrev) $replacement]
  283.     return "Saved alias in ShellPref.tcl file"
  284. }
  285.  
  286. proc Shel::prevHist {} {
  287.     global Shel::histnum Shel::curCmdLine Shel::endPrompt
  288.     
  289.     set text [getText [lineStart [getPos]] [nextLineStart [getPos]]]
  290.     if {[set ind [string first "${Shel::endPrompt} " $text]] > 0} {
  291.     goto [pos::math [lineStart [getPos]] + $ind + 2]
  292.     } else return
  293.     
  294.     incr Shel::histnum -1
  295.     if {[catch {history event ${Shel::histnum}} text]} {
  296.     incr Shel::histnum
  297.     endOfLine
  298.     beep
  299.     return
  300.     }
  301.     set to [nextLineStart [getPos]]
  302.     if {[lookAt [pos::math $to -1]] == "\r"} {set to [pos::math $to -1]}
  303.     if {[expr {${Shel::histnum} + 1}] == [history nextid] } {
  304.     set Shel::curCmdLine [getText [getPos] $to]
  305.     }
  306.     replaceText [getPos] $to $text
  307. }
  308.  
  309.  
  310. proc Shel::nextHist {} {
  311.     global Shel::histnum Shel::curCmdLine Shel::endPrompt
  312.     
  313.     set text [getText [lineStart [getPos]] [nextLineStart [getPos]]]
  314.     if {[set ind [string first "${Shel::endPrompt} " $text]] > 0} {
  315.     goto [pos::math [lineStart [getPos]] + $ind + 2]
  316.     } else return
  317.     
  318.     if {${Shel::histnum} == [history nextid]} {
  319.     beep
  320.     endOfLine
  321.     return
  322.     }
  323.     
  324.     incr Shel::histnum
  325.     if {${Shel::histnum} == [history nextid]} {
  326.     set text ${Shel::curCmdLine}
  327.     } else {
  328.     if {[catch {history event ${Shel::histnum}} text]} {
  329.         endOfLine
  330.         return
  331.     }
  332.     }
  333.     set to [nextLineStart [getPos]]
  334.     if {[lookAt [pos::math $to - 1]] == "\r"} {set to [pos::math $to -1]}
  335.     replaceText [getPos] $to $text
  336. }
  337.  
  338. proc Shel::killLine {} {
  339.     global Shel::endPrompt
  340.     set text [getText [lineStart [getPos]] [nextLineStart [getPos]]]
  341.     if {[set ind [string first "${Shel::endPrompt} " $text]] > 0} {
  342.     goto [pos::math [lineStart [getPos]] + [expr {$ind + 2}]]
  343.     } else {
  344.     return
  345.     }
  346.     set to [nextLineStart [getPos]]
  347.     if {[lookAt [pos::math $to - 1]] == "\r"} {set to [pos::math $to - 1]}
  348.     deleteText [getPos] $to
  349. }
  350.  
  351. proc Shel::Bol {} {
  352.     global Shel::endPrompt
  353.     set text [getText [lineStart [getPos]] [nextLineStart [getPos]]]
  354.     if {[set ind [string first "${Shel::endPrompt} " $text]] > 0} {
  355.     goto [pos::math [lineStart [getPos]] + [expr {$ind + 2}]]
  356.     } else {
  357.     goto [lineStart [getPos]]
  358.     }
  359. }
  360.  
  361. proc Shel::up {} {
  362.     set pos [pos::math [lineStart [getPos]] - 1]
  363.     if {[catch {regexp {∞} [getText [lineStart $pos] [nextLineStart $pos]]} res] || !$res} {
  364.     previousLine; return
  365.     }
  366.     select [lineStart $pos] [nextLineStart $pos]
  367. }
  368.  
  369. proc Shel::down {} {
  370.     set pos [nextLineStart [getPos]]
  371.     if {[catch {regexp {∞} [getText $pos [nextLineStart $pos]]} res] || !$res} {
  372.     nextLine; return
  373.     }
  374.     select $pos [nextLineStart $pos]
  375. }
  376.  
  377. # ◊◊◊◊ Unix imitation ◊◊◊◊ #
  378.  
  379. proc l {args} {
  380.     eval [concat "ls -CF" $args]
  381. }
  382.  
  383. proc ll {args} {
  384.     eval [concat "ls -l" $args]
  385. }
  386.  
  387.  
  388. proc wc {args} {
  389.     set res {}
  390.     set totChars 0
  391.     set totLines 0
  392.     set totWords 0
  393.     set args [glob -nocomplain $args]
  394.     foreach file $args {
  395.     set id [open $file]
  396.     set chars [string length [set text [read $id]]]
  397.     set lines [llength [split $text "\n"]]
  398.     set words [llength [split $text]]
  399.     append res [format "\r%8d%8d%8d    $file" $lines $words $chars]
  400.     set totChars [expr $totChars+$chars]
  401.     set totWords [expr $totWords+$words]
  402.     set totLines [expr $totLines+$lines]
  403.     close $id
  404.     }
  405.     if {[llength $args] > 1} {
  406.     append res [format "\r%8d%8d%8d    total" $totLines $totWords $totChars]
  407.     }
  408.     return [string range $res 1 end]
  409. }
  410.  
  411.  
  412.  
  413. #================================================================================
  414. # To prevent ambiguity, 'from' is assumed to be a complete pathname, ending
  415. # in a directory name. If it doesn't end w/ a colon, one is added. 'to' is
  416. # assumed to be the parent directory of the top directory we are creating.
  417. #================================================================================
  418. proc cpdir {from to} {
  419.     set cwd [pwd]
  420.     if {[string match ":*" $from] || [string match ":*" $to] ||
  421.     ![file exists $from] || ![file exists $to]} {
  422.     error "'cpdir' args must be complete pathnames of existing folders."
  423.     }
  424.     if {![string match "*:" $from]} {append from ":"}
  425.     if {![string match "*:" $to]} {append to ":"}
  426.     
  427.     if {![file isdir $from] || ![file isdir $to]} {
  428.     exit 1
  429.     }
  430.     
  431.     set res [catch {cphier $from $to} val]
  432.     cd $cwd
  433.     if {$res} {error $val}
  434. }
  435.  
  436. proc cphier {from to} {
  437.     set savedir [pwd]
  438.     if {[string index $from [expr [string len $from] - 1]] != ":"} {append from ":"}
  439.     set dir [file tail [string trimright $from ":"]]
  440.     cd $to
  441.     mkdir "$dir"
  442.     foreach f [glob "$from*"] {
  443.     if {[file isdir $f]} {
  444.         cphier "$f:" "$to$dir:"
  445.     } else {
  446.         cp $f $to$dir:
  447.     }
  448.     }
  449.     cd $savedir
  450. }
  451.  
  452.         
  453. #================================================================================
  454. #####
  455. # (Usage:  'lt' sorts by time, like UNIX's 'ls -lt'.
  456. #          'lt -t' sorts by filename, like UNIX's 'ls -l'.
  457. #          Optionally a directory name can be added as an argument.)
  458.  
  459. proc sortdt {dt} {
  460.     scan $dt "%d/%d/%d {%d:%d:%d %1sM}" mon day yea hou min sec z
  461.     if {$z == "P"} {incr hou 12}
  462.     if {[string length $yea] == 1} {
  463.     set year 200$yea
  464.     } elseif {$yea > 40} {
  465.     set year 19$yea
  466.     } else {
  467.     set year 20$yea
  468.     }
  469.     return [format "%04d%02d%02d%02d%02d" $year $mon $day $hou $min]
  470. }
  471.  
  472.  
  473. #===============================================================================
  474. #####
  475. # (Usage:  'lth' sorts by time, like UNIX's 'ls -lt'.
  476. #          'lth -t' sorts by filename, like UNIX's 'ls -l'.
  477. #
  478. #     Optionally a filename path pattern can be added as an argument.
  479. #       Examples:
  480. #
  481. #           lth :Help:*
  482. #           lth :Help:D*
  483. #           lth HardDisk:news:*
  484. #           lth HardDisk:news:R*
  485. #           lth -t HardDisk:*
  486. #
  487. #       are all good, if you have a volume named "HardDisk" and a
  488. #       folder named "news" on it, but
  489. #       
  490. #           lth Help
  491. #           lth :Help:
  492. #
  493. #       are both bad.
  494. #
  495. #       Use
  496. #       
  497. #           lth {"Macintosh Hd:*"}
  498. #       
  499. #       if you have spaces in the file or folder names.)
  500. #
  501. #    This procedure is based only on the abbreviated format for dates and 
  502. #    time. It does not rely anymore on the short date format which avoids
  503. #    problems such that 'Jan 2' giving either '1/2' (US) or '2/1' (UK).
  504. #    
  505. #    It assumes that :
  506. #    1. dates are coded as a four item list with a four digit field for years
  507. #    and a two digit one for days (plus possible non-digit separators),
  508. #    while weekdays and months are coded with characters in [\w] (plus
  509. #    possible separators in [^\w]);
  510. #    2. day and month fields are consecutive ones and weekday field is before 
  511. #    them when the year field is either the first or the last one;
  512. #    3. time uses 'a' and 'p' in the strings coding twelve hour clocks (case
  513. #    insensitive).
  514. #    
  515. #    This should cover most Mac OS formats for (north) America and Europe
  516. #    ({weekday month day year} or {weekday day month year}), but not
  517. #    non-latin encodings or slavic languages using (for month) characters
  518. #    which are not in the default [\w] set.
  519. #    
  520. #    In (some) Mac OS, the Finnish abbreviated dates use up to six characters.
  521. #    Allowing for month names with up to six characters gives an ugly and
  522. #    confusing result for languages using three (or four) characters, thus
  523. #    the procedure uses only 'ns' characters, where 'ns' is set to 4.
  524. #
  525.  
  526. proc lth args {
  527.     global mode
  528.     
  529.     set date [lindex [mtime [now] a] 0]
  530.     
  531. #
  532. #    Try to find the most likely format for dates.
  533. #
  534.     
  535.     set nmb [regexp "(\[0-9\]+)\[^0-9\]*(\[0-9\]+)" $date t one two]
  536.     if {$nmb != 1} {
  537.     error "Error while scanning the date stamp"
  538.     }
  539.     if {[string length $one] == 4} {
  540.     set year $one
  541.     set day  $two
  542.     } elseif {[string length $two] == 4} {
  543.     set year $two
  544.     set day  $one
  545.     } else {
  546.     error "Error: cannot find the year"
  547.     }
  548.     set i 0
  549.     set indd -1
  550.     set indy -1
  551.     foreach f $date {
  552.     if {[regexp "\[0-9\]+" $f f]} {
  553.         if {$f == $year} {set indy $i}
  554.         if {$f == $day} {set indd $i}
  555.     }
  556.     incr i
  557.     }
  558.     if {($indy == 2) || ($indy == 3)} {
  559.     if {$indd == [expr {$indy - 2}]} {
  560.         set indm [expr {$indy - 1}]
  561.     } elseif {$indd == [expr {$indy - 1}]} {
  562.         set indm [expr {$indy - 2}]
  563.     } else {
  564.         error "Error: date format unknown"
  565.     }
  566.     } elseif {($indy == 0) || ($indy == 1)} {
  567. #
  568. #       If your date format is {year month day weekday} or 
  569. #       {year day month weekday} uncomment the following 'if' 'elseif'
  570. #       'else' block and comment the next one.
  571. #       
  572. #     if {$indd == [expr {$indy + 2}]} {
  573. #         set indm [expr {$indy + 1}]
  574. #     } elseif {$indd == [expr {$indy + 1}]} {
  575. #         set indm [expr {$indy + 2}]
  576. #     } else {
  577. #         error "Error: date format unknown"
  578. #     }
  579. #
  580.     if {$indd == 2} {
  581.         set indm 3
  582.     } elseif {$indd == 3} {
  583.         set indm 2
  584.     } else {
  585.         error "Error: date format unknown"
  586.     }
  587.     } else {
  588.     error "Error: date format unknown"
  589.     }
  590.  
  591. #
  592. #    If you want to set manually the location of the different fields
  593. #    comment (or remove) the lines between the comment
  594. #    "Try to find the most likely format for dates." above and this block 
  595. #    and uncomment the following lines with 'yourXxxField' replaced
  596. #    by a number between 0 and '[llength $date] - 1'.
  597. #    
  598. #    set indd yourDayField
  599. #    set indm yourMonthField
  600. #    set indy yourYearField
  601. #    set year [lindex $date $indy]
  602. #
  603.     
  604.     set val "*"
  605.     set sort 1
  606.  
  607.     foreach arg $args {
  608.     switch -- $arg {
  609.         "-t"    {set sort 0}
  610.         default {set val $arg}
  611.     }
  612.     }
  613.     
  614. #
  615. #    If you want the full Finnish abbreviated form, set 'ns' to 6;
  616. #    if you want only three letters for the month, set 'ns' to 3.
  617. #
  618.     
  619.     set ns 4
  620.     set nsp [expr {$ns + 1}]
  621.     set nf [expr {$ns + 4}]
  622.     set mod ""
  623.     foreach f [eval glob $val] {
  624.     if {[catch {getFileInfo $f info}]} {
  625.         if {$sort} {set mod "            "}
  626.         lappend text [format "%s%s %8d%8d %${nf}s %5s %4s %s %s\n" \
  627.               $mod "D" "0" "0" "" "" "" "DIR " [file tail $f]]
  628.         continue
  629.     }
  630.     if {$sort} {set mod [format "%12u" $info(modified)]}
  631.     set m [mtime $info(modified) a]
  632.     set zer [lindex $m 0]
  633.     regexp "(\[0-9\]+)" [lindex $zer $indd] day
  634.     regexp "(\\w+)" [lindex $zer $indm] month
  635.     set month [string range $month 0 [expr {$ns - 1}]]
  636.     if {$indd < $indm} {
  637.         for {set i [string length $month]} {$i < $ns} {incr i} {
  638.         set month "$month "
  639.         }
  640.         set dat [format "%3s %${ns}s" $day $month]
  641.     } else {
  642.         set dat [format "%${nsp}s %2s" $month $day]
  643.     }
  644.     if {[lindex $zer $indy] == $year} {
  645.         set time [lindex $m 1]
  646.         set nmb [regexp "(\[0-9\]+)(\[^0-9\]+)(\[0-9\]+)" \
  647.              $time t hour sep min]
  648.         if {$nmb != 1} {
  649.         error "Error while scanning the time stamp"
  650.         }
  651.         if {[regexp -nocase "p" $time] && ($hour < 12)} { 
  652.         set hour [expr $hour + 12] 
  653.         }
  654.         if {[regexp -nocase "a" $time] && ($hour == 12)} { 
  655.         set hour [expr $hour - 12] 
  656.         }
  657.         if {[string length $min] == 1} {set min "0$min"}
  658.         set tm "$hour$sep$min"
  659.     } else {
  660.         regexp "(\[0-9\]+)" [lindex $zer $indy] yea
  661.         set tm " $yea"
  662.     }
  663.     lappend text [format "%sF %8d%8d %${nf}s %5s %s %s %s\n" \
  664.               $mod $info(datalen) $info(resourcelen) $dat $tm \
  665.               $info(type) $info(creator) [file tail $f]]
  666.     }
  667.     if {$sort} {
  668.     foreach ln [lsort -de $text] {
  669.         append txt [string range $ln 12 end]
  670.     }
  671.     set ans [string trimright $txt]
  672.     } else {
  673.     set ans [string trimright [join $text {}]]
  674.     }
  675.     
  676.     if { $mode=="Shel" } { 
  677.     return $ans 
  678.     } else {
  679.     new
  680.     insertText $ans "\r"
  681.     catch shrinkHeight
  682.     setWinInfo dirty 0
  683.     setWinInfo read-only 1
  684.     }
  685. }
  686.  
  687.  
  688. #================================================================================
  689. proc ps {} {
  690.     foreach p [processes] {
  691.     append text [format "%-25s %4s %10d %10d\r" [lindex $p 0] [lindex $p 1] [lindex $p 2] [lindex $p 3]]
  692.     }
  693.     return [string trimright $text]
  694. }
  695.  
  696.  
  697. #================================================================================
  698. # Recursively make creator of all text files 'ALFA'. Optionally takes a starting
  699. # dir argument, otherwise starts in current directory. Auto-Doubled are no 
  700. # longer recognized by auto-doubler! Why? Some sort of conflict w/ 'PBSetFInfo'.
  701. proc creator {{dir ":"}}  {
  702.     if {![catch {glob -t TEXT $dir*} files]} {
  703.     foreach f $files {
  704.         message $f
  705.         setFileInfo $f creator ALFA
  706.     }
  707.     }
  708.     
  709.     if {![catch {glob $dir*} dirs]} {
  710.     foreach d $dirs {
  711.         if {[file isdir $d]} {creator $d:}
  712.     }
  713.     }
  714. }
  715.  
  716.  
  717. #===============================================================================
  718.  
  719. proc tomac args {
  720.     set files {}
  721.     foreach arg $args {
  722.     eval lappend files [glob -nocomplain -- $arg]
  723.     }
  724.     set dir [pwd]
  725.     
  726.     foreach f $files {
  727.     message "$f..."
  728.     set fd [open [file join $dir $f] "r"]
  729.     set text [read $fd]
  730.     close $fd
  731.     if {[info tclversion] < 8.0} {
  732.         regsub -all "\n" $text "\r" text
  733.     }
  734.     
  735.     set fd [open [file join $dir $f] "w"]
  736.     puts -nonewline $fd $text
  737.     close $fd
  738.     }
  739.     message ""
  740. }
  741.  
  742.  
  743. #===============================================================================
  744.  
  745. proc unixToMac {fname} {
  746.     set fd [open $fname]
  747.     set text [read $fd]
  748.     close $fd
  749.     set fd [open $fname "w"]
  750.     puts -nonewline $fd $text
  751.     close $fd
  752. }
  753.  
  754. proc setCreator {creator args} {
  755.     set files {}
  756.     foreach arg $args {
  757.     eval lappend files [glob -nocomplain $arg]
  758.     }
  759.     foreach f $files {
  760.     setFileInfo $f creator $creator
  761.     }
  762. }
  763.  
  764. proc setType {type args} {
  765.     set files {}
  766.     foreach arg $args {
  767.     eval lappend files [glob -nocomplain $arg]
  768.     }
  769.     foreach f $files {
  770.     setFileInfo $f type $type
  771.     }
  772. }
  773. #===============================================================================
  774.  
  775. proc pushd {args} {
  776.     global otherDirs
  777.     if {[string length $args]} {
  778.     set otherDirs [cons [pwd] $otherDirs]
  779.     cd [string trim [eval list $args] "        \{\}"]
  780.     } else {
  781.     if {[llength $otherDirs]} {
  782.         set n [car $otherDirs]
  783.         set otherDirs [cons [pwd] [cdr $otherDirs]]
  784.         cd $n
  785.     } else {
  786.         return "No other directories"
  787.     }
  788.     }
  789. }
  790. proc pd {args} {
  791.     if {[string length $args]} {
  792.     eval pushd $args
  793.     } else {
  794.     pushd
  795.     }
  796. }
  797.  
  798.  
  799. proc dirs {} {global otherDirs; cons [pwd] $otherDirs}
  800.  
  801. proc popd {} {
  802.     global otherDirs
  803.     if {[llength $otherDirs]} {
  804.     cd [car $otherDirs]
  805.     set otherDirs [cdr $otherDirs]
  806.     } else {
  807.     return "No other directories"
  808.     }
  809. }
  810.  
  811.